PC Plus SuperCD (UK) 1997 February

home *** CD-ROM | disk | FTP | other *** search

/ PC Plus SuperCD (UK) 1997 February / PC Plus Super CD (Issue 124) (PCP124-2-97) (February 1997).iso / handson / vbwkshp / mciapp.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1996-11-08 | 57.6 KB | 1,801 lines

VERSION 4.00 Begin VB.Form MCIApp BackColor = &H00C0C0C0& ClientHeight = 4680 ClientLeft = 2280 ClientTop = 2100 ClientWidth = 5535 ForeColor = &H00000000& Height = 5085 Icon = "MCIAPP.frx":0000 KeyPreview = -1 'True Left = 2220 LinkMode = 1 'Source LinkTopic = "Form4" ScaleHeight = 4680 ScaleWidth = 5535 Top = 1755 Width = 5655 Begin VB.CommandButton cmdCherish Caption = "&Copy To Favourites" Enabled = 0 'False Height = 465 Left = 2280 TabIndex = 10 Top = 4110 Width = 1515 End Begin VB.TextBox txtSpeed Alignment = 2 'Center BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 9.75 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 360 Left = 4290 Locked = -1 'True MultiLine = -1 'True TabIndex = 17 TabStop = 0 'False Text = "MCIAPP.frx":030A Top = 4680 Width = 375 End Begin VB.CommandButton cmdUp Caption = ">" Height = 375 Left = 5190 TabIndex = 15 Top = 4680 Width = 225 End Begin VB.CommandButton cmdDown Caption = "<" Height = 375 Left = 4020 TabIndex = 14 Top = 4680 Width = 225 End Begin VB.CommandButton cmdRoll Caption = "&Roll Graphics Every >" Enabled = 0 'False Height = 375 Left = 2070 TabIndex = 13 Top = 4680 Width = 1875 End Begin VB.CommandButton cmdHold Caption = "&Hold Graphics" Height = 375 Left = 120 TabIndex = 12 Top = 4680 Width = 1875 End Begin VB.Timer Timer3 Enabled = 0 'False Interval = 10000 Left = 1020 Top = 4020 End Begin VB.CheckBox chkLoop BackColor = &H00C0C0C0& Caption = "&Loop" Height = 195 Left = 4740 TabIndex = 5 Top = 3360 Width = 195 End Begin VB.Timer Timer2 Left = 540 Top = 4020 End Begin VB.CheckBox chkPlaySelect BackColor = &H00C0C0C0& Height = 195 Left = 2280 TabIndex = 3 Top = 3360 Width = 195 End Begin VB.CommandButton cmdDone BackColor = &H00C0C0C0& Caption = "I've Heard &Enough" Height = 465 Left = 3900 TabIndex = 11 Top = 4110 Width = 1515 End Begin VB.Timer Timer1 Left = 60 Top = 4020 End Begin VB.CheckBox chkPlayAll BackColor = &H00C0C0C0& ForeColor = &H00000000& Height = 195 Left = 3810 TabIndex = 4 Top = 3360 Width = 195 End Begin VB.DriveListBox Drive1 BackColor = &H00FFFFFF& BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 315 Left = 2280 TabIndex = 0 Top = 2880 Width = 3135 End Begin VB.DirListBox Dir1 BackColor = &H00FFFFFF& BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 2280 Left = 2280 TabIndex = 1 Top = 480 Width = 3135 End Begin VB.FileListBox File1 BackColor = &H00FFFFFF& BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 3180 Left = 120 MultiSelect = 2 'Extended Pattern = "*.mid" TabIndex = 2 Top = 480 Width = 1995 End Begin VB.HScrollBar HScroll1 Height = 255 Left = 120 Max = 100 TabIndex = 6 TabStop = 0 'False Top = 3720 Width = 5295 End Begin VB.Label Label5 BackStyle = 0 'Transparent Caption = "Loop" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 225 Left = 4980 TabIndex = 21 Top = 3360 Width = 465 End Begin VB.Label Label4 BackStyle = 0 'Transparent Caption = " Play All" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 225 Left = 3990 TabIndex = 20 Top = 3360 Width = 705 End Begin VB.Label Label3 BackStyle = 0 'Transparent Caption = " Play Selection" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 225 Left = 2460 TabIndex = 19 Top = 3360 Width = 1305 End Begin VB.Label Label1 BackColor = &H0000FFFF& BackStyle = 0 'Transparent Caption = "secs" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H00FFFFFF& Height = 255 Left = 4710 TabIndex = 18 Top = 4740 Width = 465 End Begin VB.Image Image1 Height = 7335 Index = 9 Left = 5760 Picture = "MCIAPP.frx":030D Stretch = -1 'True Top = 240 Visible = 0 'False Width = 6015 End Begin VB.Image Image1 Height = 7335 Index = 8 Left = 5760 Picture = "MCIAPP.frx":3AF5 Stretch = -1 'True Top = 240 Visible = 0 'False Width = 6015 End Begin VB.Image Image1 Height = 7335 Index = 7 Left = 5760 Picture = "MCIAPP.frx":75F7 Stretch = -1 'True Top = 240 Visible = 0 'False Width = 6015 End Begin VB.Image Image1 Height = 7335 Index = 6 Left = 5760 Picture = "MCIAPP.frx":A655 Stretch = -1 'True Top = 240 Visible = 0 'False Width = 6015 End Begin VB.Image Image1 Height = 7335 Index = 5 Left = 5760 Picture = "MCIAPP.frx":169BF Stretch = -1 'True Top = 240 Visible = 0 'False Width = 6015 End Begin VB.Image Image1 Height = 7335 Index = 4 Left = 5760 Picture = "MCIAPP.frx":1A459 Stretch = -1 'True Top = 240 Visible = 0 'False Width = 6015 End Begin VB.Image Image1 Height = 7335 Index = 3 Left = 5760 Picture = "MCIAPP.frx":1E4AB Stretch = -1 'True Top = 240 Visible = 0 'False Width = 6015 End Begin VB.Image Image1 Height = 7335 Index = 2 Left = 5760 Picture = "MCIAPP.frx":21139 Stretch = -1 'True Top = 240 Visible = 0 'False Width = 6015 End Begin VB.Image Image1 Height = 7335 Index = 1 Left = 5760 Picture = "MCIAPP.frx":226BD Stretch = -1 'True Top = 240 Visible = 0 'False Width = 6015 End Begin VB.Image Image2 Height = 2550 Index = 9 Left = 120 Picture = "MCIAPP.frx":26DBB Stretch = -1 'True Top = 5160 Visible = 0 'False Width = 5295 End Begin VB.Image Image2 Height = 2550 Index = 8 Left = 120 Picture = "MCIAPP.frx":2B811 Stretch = -1 'True Top = 5160 Visible = 0 'False Width = 5295 End Begin VB.Image Image2 Height = 2550 Index = 7 Left = 120 Picture = "MCIAPP.frx":31DF3 Stretch = -1 'True Top = 5160 Visible = 0 'False Width = 5295 End Begin VB.Image Image2 Height = 2550 Index = 6 Left = 120 Picture = "MCIAPP.frx":3900F Stretch = -1 'True Top = 5160 Visible = 0 'False Width = 5295 End Begin VB.Image Image2 Height = 2550 Index = 5 Left = 120 Picture = "MCIAPP.frx":3AF29 Stretch = -1 'True Top = 5160 Visible = 0 'False Width = 5295 End Begin VB.Image Image2 Height = 2550 Index = 4 Left = 120 Picture = "MCIAPP.frx":42D07 Stretch = -1 'True Top = 5160 Visible = 0 'False Width = 5295 End Begin VB.Image Image2 Height = 4485 Index = 3 Left = 120 Picture = "MCIAPP.frx":4E01D Stretch = -1 'True Top = 5160 Visible = 0 'False Width = 7410 End Begin VB.Image Image2 Height = 2550 Index = 2 Left = 120 Picture = "MCIAPP.frx":5078B Stretch = -1 'True Top = 5160 Visible = 0 'False Width = 5295 End Begin VB.Image Image2 Height = 2550 Index = 1 Left = 120 Picture = "MCIAPP.frx":51441 Stretch = -1 'True Top = 5160 Visible = 0 'False Width = 5295 End Begin VB.Image Image2 Height = 2550 Index = 0 Left = 120 Picture = "MCIAPP.frx":56B03 Stretch = -1 'True Top = 5160 Width = 5295 End Begin VB.Image Image1 Height = 7335 Index = 0 Left = 5760 Picture = "MCIAPP.frx":5E8E1 Stretch = -1 'True Top = 240 Width = 6015 End Begin MCI.MMControl MMSelect Height = 495 Left = 120 TabIndex = 7 Top = 4080 Width = 3660 _Version = 65536 AutoEnable = 0 'False _ExtentX = 6456 _ExtentY = 873 _StockProps = 32 End Begin MCI.MMControl MMSingle Height = 495 Left = 120 TabIndex = 9 Top = 4080 Width = 3660 _Version = 65536 _ExtentX = 6456 _ExtentY = 873 _StockProps = 32 End Begin MCI.MMControl MMAll Height = 495 Left = 120 TabIndex = 8 Top = 4080 Width = 3660 _Version = 65536 AutoEnable = 0 'False _ExtentX = 6456 _ExtentY = 873 _StockProps = 32 End Begin VB.Label Label2 Alignment = 2 'Center BackStyle = 0 'Transparent BeginProperty Font name = "Courier" charset = 0 weight = 700 size = 9.75 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 255 Left = 0 TabIndex = 16 Top = 120 Width = 5535 End Attribute VB_Name = "MCIApp" Attribute VB_Creatable = False Attribute VB_Exposed = False 'Constants & variables relative to MCIApp form 'Constants for MCI controls Const conInterval = 50 Const conIntervalPlus = 55 Const vbMCIModePlay = 526 'Constants used when WindowState is < 2 (maximised) Const white = &HFFFFFF Const black = &H0 Const grey = &HC0C0C0 'Form level variables Dim CurrentValue As Double Dim DefH As Integer, DefW As Integer Dim a As Integer, s As Integer Dim msecs Dim Drv As Integer Sub Handle_Error() 'What was the error number ? Select Case Err Case 76 'Path not found' 'So make it MkDir FavouritesPath Beep MsgBox "Favourites' folder was missing !" & Chr(10) & Chr(13) & Chr(13) & "A new one has been created.", 64, "MIDI CYCLOTRON" Case 68 'Device Unavailable (No floppy disc or CD inserted) MsgBox "Device Not Available !" & Chr(10) & Chr(10) & Chr(13) & "(Perhaps there is no floppy disc or CD in the drive.)", 48, "MIDI CYCLOTRON" 'So set drive to App.Path Drive1.Drive = App.Path 'Otherwise, Case Else 'we didn't expect it Beep MsgBox "Unexpected error !" & Chr(10) & Chr(10) & Chr(13) & "Midi Cyclotron will now shut down !", 16, "MIDI CYCLOTRON" 'So end Unload Me End End Select End Sub Private Sub chkLoop_Click() 'If loop has been selected then If chkLoop.value = 1 Then 'check to see if both multi play options are unchecked If chkPlayAll.value = 0 And chkPlaySelect.value = 0 Then 'If so, then uncheck loop as it is not valid chkLoop.value = 0 End If End If End Sub Private Sub chkPlayAll_Click() 'Check to test if both multi play options 'are being set to off If chkPlayAll.value = 0 And chkPlaySelect.value = 0 Then 'If so, then set loop to off as it is no longer valid chkLoop.value = 0 'If 'Play Selection' is checked then uncheck it 'We only want one option chosen ElseIf chkPlaySelect.value = 1 Then chkPlaySelect.value = 0 End If 'If playing ALL If chkPlayAll.value = 1 Then 'then test for files not displayed 'If none are displayed If Me.File1.ListCount = 0 Then 'then tell user Beep MsgBox "No files displayed !", 48, "MIDI CYCLOTRON" 'uncheck Play All chkPlayAll.value = 0 'and exit Exit Sub End If 'Determine file to start with frmOptions.Show 1 'Play All was cancelled If Cancelled = True Then 'so reset variable Cancelled = False 'uncheck Play All chkPlayAll.value = 0 'and exit Exit Sub End If 'What was chosen ? If StartWhere = 0 Then 'First chosen 'Start at beginning i = 0 ElseIf StartWhere = 1 Then 'Number entered 'Start at number entered i = StartNumber - 1 'Set 'resume at' var' FileMark = i ElseIf StartWhere = 2 Then 'Name entered 'Set a flag Flag = 0 'Name entered so loop to match names For C = 0 To Me.File1.ListCount - 1 'If match then If Me.File1.List(C) = StartName Then 'Set file number to play i = C 'Set 'resume at' var' FileMark = i 'and exit loop Exit For 'Otherwise, if we are at end of list and Flag = 0 (no names matched) ElseIf C = Me.File1.ListCount - 1 And Me.File1.List(C) <> StartName Then 'then tell user Beep MsgBox "File name not found in list", 64, "MIDI CYCLOTRON" 'Uncheck box chkPlayAll.value = 0 'and exit Exit Sub End If 'Loop if not at end Next C 'Otherwise 'resume at' was chosen ElseIf StartWhere = 3 Then i = FileMark End If 'Bring 'Play All' MCI to front MMAll.ZOrder 0 'Close single play in case it is running MMSingle.Command = "Close" 'andstart the timer to play all files in turn Timer1.Interval = 1 'Otherwise, it is unchecked so close play all Else MMAll.Command = "Close" 'Reset form label caption Label2.Caption = File1.ListCount & " Files" 'and bring single play MCI to front MMSingle.ZOrder 0 'and reset the file counter i = 0 End If End Sub Private Sub chkPlaySelect_Click() 'Check to test if both multi play options are being set to off If chkPlayAll.value = 0 And chkPlaySelect.value = 0 Then 'If so, then force loop to off. It's not valid chkLoop.value = 0 'Uncheck 'Play All' just in case ElseIf chkPlayAll.value = 1 Then chkPlayAll.value = 0 'Reset 'resume at' var' FileMark = -1 End If 'If play selected is checked If chkPlaySelect.value = 1 Then 'Test for files not displayed or selected Flag = 0 'Test for files displayed and/or selected If File1.ListCount = 0 Then 'set message word RightWord = "displayed" 'jump to message GoTo NoHilite Else 'Otherwise there are files displayed For X = 0 To File1.ListCount - 1 'so loop to check for a selection If File1.Selected(X) Then Flag = 1 'If this is a fresh session of 'Play Selection' (Filemark = -1) then If FileMark = -1 Then 'the fourth play option is not valid frmOptions.optMethod(3).Enabled = False frmOptions.txtResume.Visible = False 'Exit loop Exit For 'Otherwise, Else 'it is valid frmOptions.txtResume.Visible = True frmOptions.txtResume.Text = Str(FileMark + 1) 'Exit loop Exit For End If End If 'loop if necessary Next X End If 'Test flag If Flag = 0 Then 'set message word RightWord = "selected" End If 'Jump label NoHilite: 'If none selected or displayed If Flag = 0 Or File1.ListCount = 0 Then 'tell user Beep MsgBox "No files " & RightWord & " !", 48, "MIDI CYCLOTRON" 'Uncheck chkPlaySelect.value = 0 'and exit Exit Sub End If 'Fall thro ' to here if option checked and files displayed and selected 'Determine file to start with frmOptions.optMethod(0).Caption = "First file in selection" frmOptions.Show 1 'If play selection cancelled If Cancelled = True Then 'then reset variable Cancelled = False 'reset form label default caption frmOptions.optMethod(0).Caption = "First file" 'uncheck Play Selection chkPlaySelect.value = 0 'and exit Exit Sub End If 'Set form label default caption frmOptions.optMethod(0).Caption = "First file" 'What was chosen ? If StartWhere = 0 Then 'First chosen 'Start at beginning y = 0 ElseIf StartWhere = 1 Then 'Number entered 'Start at number entered y = StartNumber - 1 ElseIf StartWhere = 2 Then 'Name entered so loop to match names For B = 0 To Me.File1.ListCount - 1 'If match then If Me.File1.List(B) = StartName Then 'If it's in selection then If Me.File1.Selected(B) Then 'Set file number to play y = B 'and exit loop Exit For End If 'Otherwise, if we are at end of list and Flag = 0 (no names matched) ElseIf B = Me.File1.ListCount - 1 And Me.File1.List(B) <> StartName Then 'then tell user Beep MsgBox "File name not found in selection", 64, "MIDI CYCLOTRON" 'Uncheck box chkPlaySelect.value = 0 'and exit Exit Sub End If 'Loop if not at end Next B 'Otherwise, ElseIf StartWhere = 3 Then 'start at last file played in this session y = FileMark End If 'Bring 'Play Selected' MCI to front MMSelect.ZOrder 0 'Close single play MCI in case it is running MMSingle.Command = "Close" 'and start the timer to play selected files Timer2.Interval = 1 'Otherwise, Else 'uncheck play selected chkPlaySelect.value = 0 'Close the device MMSelect.Command = "Close" 'Reset form label caption Label2.Caption = File1.ListCount & " Files" 'and bring single play MCI to front MMSingle.ZOrder 0 'Reset file counter y = 0 End If End Sub Private Sub cmdCherish_Click() 'We don't want to crash if 'Favourites' folder has 'been moved or deleted ! 'So test for it On Error GoTo Handle_It ChDir FavouritesPath 'Now change back to App's path since the 'Favourites' folder now 'positively exists one way or the other '(See form level procedure 'Handle_It') ChDir App.Path 'If multi selections are in effect then a file will be playing (The one to copy) 'Otherwise, single play is in effect so, If chkPlayAll.value = 0 And chkPlaySelect.value = 0 Then 'Dim a flag Flag = 0 'Test File1 for a current selection For z = 0 To File1.ListCount - 1 'If a file is select then set flag If File1.Selected(z) Then Flag = 1 'and exit loop Exit For End If 'Otherwise loop Next z 'If Flag is unset then none are selected If Flag = 0 Then Beep 'there is just the first file, File1's default filename 'and none are selected '(Not the intended purpose of the button) MsgBox "No Current File !", 48, "MIDI CYCLOTRON" 'so exit Exit Sub End If End If 'If in single play mode then If chkPlaySelect.value = 0 And chkPlayAll.value = 0 Then 'The Right Name = File1.Filename 'The one selected, playing or just played RightName = File1.filename 'Otherwise if Play Selection then ElseIf chkPlaySelect.value = 1 Then 'The Right Name = File1.List(y-1). The one currently playing '(When the timer played the file it incremented it's counter) RightName = File1.List(y - 1) 'Otherwise if Play All then ElseIf chkPlayAll.value = 1 Then 'The Right Name = File1.List(i - 1). The one currently playing '(When the timer played the file it incremented it's counter) RightName = File1.List(i - 1) End If 'Copy the file testing for the root If Right(Dir1.Path, 1) = "\" Then FileCopy Dir1.Path & RightName, FavouritesPath & "\" & RightName Else FileCopy Dir1.Path & "\" & RightName, FavouritesPath & "\" & RightName End If 'and tell the user it's done Beep MsgBox UCase(RightName) & " copied successfully", 64, "MIDI CYCLOTRON" 'Exit before error handling Exit Sub 'Handle 'path not found error' Handle_It: 'Form level subroutine (See 'General') Handle_Error 'Go back to the line following the one causing the error Resume Next End Sub Private Sub cmdCherish_KeyPress(KeyAscii As Integer) 'If enter is pressed If KeyAscii = 13 Then 'stop dreaded beep KeyAscii = 0 'and activate file copy event cmdCherish_Click End If End Sub Private Sub cmdDone_Click() 'Trigger form unload event Form_Unload (0) End Sub Private Sub cmdDone_KeyPress(KeyAscii As Integer) 'If enter is pressed then If KeyAscii = 13 Then 'stop dreaded beep KeyAscii = 0 'and trigger click event cmdDone_Click End If End Sub Private Sub cmdDown_Click() 'If timer interval = 5 it can't be lower so loop If s = 5 Then s = 60 'Otherwise, Else 'decrease it by 5 s = s - 5 End If 'Display it txtSpeed.Text = s 'Then set timer interval accordingly (1000 = approx 1 sec.) '(s, (an integer), * 1000 causes an overflow error when s is > 30) ??? Timer3.Interval = s * 100 & 0 '(This doesn't) ??? '(This is a workaround but it's less code than say, 'Select Case s' ) 'New interval will be applied after current interval End Sub Private Sub cmdDown_KeyPress(KeyAscii As Integer) 'If enter Is pressed then If KeyAscii = 13 Then 'stop dreaded beep KeyAscii = 0 'and trigger click event cmdDown_Click End If End Sub Private Sub cmdHold_Click() 'Stop graphics from rolling Timer3.Enabled = False 'Disable Hold cmdHold.Enabled = False 'Enable Roll cmdRoll.Enabled = True End Sub Private Sub cmdHold_KeyPress(KeyAscii As Integer) 'If enter Is pressed then If KeyAscii = 13 Then 'stop dreaded beep KeyAscii = 0 'and trigger click event cmdHold_Click End If End Sub Private Sub cmdRoll_Click() 'Seed the random number generator using the 'return value of the system timer Randomize 'Roll graphics Timer3.Enabled = True 'Disable Roll cmdRoll.Enabled = False 'Enable Hold cmdHold.Enabled = True End Sub Private Sub cmdRoll_KeyPress(KeyAscii As Integer) 'If enter is pressed then If KeyAscii = 13 Then 'stop dreaded beep KeyAscii = 0 'and trigger click event cmdRoll_Click End If End Sub Private Sub cmdUp_Click() 'If timer interval is at 60 it can't be greater so loop If s = 60 Then s = 5 'Otherwise Else 'increase it by 5 s = s + 5 End If 'and display it txtSpeed.Text = s 'Then set timer interval accordingly (1000 = approx 1 sec.) '(s, (an integer), * 1000, causes an overflow error when s is > 30) ??? Timer3.Interval = s * 100 & 0 '(This doesn't) ??? '(This is a workaround but it's less code than say, 'Select Case s' ) 'New interval will be applied after current interval End Sub Private Sub cmdUp_KeyPress(KeyAscii As Integer) 'If enter is pressed then If KeyAscii = 13 Then 'stop dreaded beep KeyAscii = 0 'and trigger click event cmdUp_Click End If End Sub Private Sub Dir1_Change() 'Set file list to Folder path File1.Path = Dir1.Path End Sub Private Sub Drive1_Change() On Error GoTo Handle_It 'Set folder path to selected drive Dir1.Path = Drive1.Drive Exit Sub 'Arrive here if no floppy in a:\ or b:\ Handle_It: Handle_Error Exit Sub End Sub Private Sub File1_Click() End Sub Private Sub File1_DblClick() 'Play A Single File ! 'If either Play Selection or Play All is checked then 'double-click not applicable If chkPlayAll.value = 1 Or chkPlaySelect.value = 1 Then 'so exit Exit Sub 'Otherwise Else 'Dim variable for MCI update interval Dim msec As Double ' Set the number of milliseconds between successive ' StatusUpdate events. (0 = stops it) MMSingle.UpdateInterval = 0 ' If the single play device is open, close it. If Not MMSingle.Mode = vbMCIModeNotOpen Then MMSingle.Command = "Close" End If 'Test for root dir If Right(Dir1.Path, 1) = "\" Then 'Set path to root FilePath = Dir1.Path & File1.filename Else 'Otherwise set to heirarchal structure FilePath = Dir1.Path & "\" & File1.filename End If ' Open the device with the new filename. MMSingle.filename = FilePath 'Trap possible errors On Error GoTo MCI_ERROR 'Open the device MMSingle.Command = "Open" 'Trap possible errors On Error GoTo 0 'Set caption for form Caption = DialogCaption + File1.filename & " File number " & File1.ListIndex + 1 'Activate MMSingle_Done event when finished to reset form label MMSingle.Notify = True ' Set the timing format for the scroll bar. MMSingle.TimeFormat = vbMCIFormatMilliseconds msec = (CDbl(MMSingle.Length) / 1000) 'Set form label caption to show length 'If less than 1 minute then If msec < 60 Then 'show only seconds Label2.Caption = File1.ListCount & " Files. Music Length " & Int(msec) & " Secs." 'Otherwise, Else 'show minutes and seconds Label2.Caption = File1.ListCount & " Files. Music Length " & Int(msec / 60) & " Mins." & msec Mod (60) & " Secs." End If 'msec is Private. msecs is Public & is used by MCI control 'to reset form label caption if file has been stopped 'then restarted msecs = msec ' Set the scrollbar values. Hscroll1.value = 0 CurrentValue = 0# 'Start playing MMSingle.Command = "Play" 'Start incrementing scroll bar MMSingle.UpdateInterval = conInterval 'Exit before error handling Exit Sub End If MCI_ERROR: DisplayErrorMessageBox Resume MCI_EXIT MCI_EXIT: Unload Me End Sub Private Sub File1_KeyPress(KeyAscii As Integer) 'If 'Enter' is pressed and single play is in effect If KeyAscii = 13 And chkPlayAll.value = 0 And chkPlaySelect.value = 0 Then 'then stop dreaded Beep! KeyAscii = 0 'and activate double-click event (which see) File1_DblClick 'Otherwise, Else 'just stop Beep! KeyAscii = 0 End If End Sub Private Sub File1_PathChange() 'Reset form caption every time Me.Caption = "MIDI CYCLOTRON " 'If list has changed then if files are displayed If File1.ListCount > 0 Then 'show number of files in form label caption Label2.Caption = File1.ListCount & " Files" 'Is the application being run from a 'non writeable' drive ? 'If it is then, If Drv < 2 Or Drv > 4 Then 'disable 'copy to favourites' button regardless cmdCherish.Enabled = False 'and jump GoTo SkipDir End If 'Otherwise, enable the file copy button if NOT logged 'on to 'Favourites' checkforfolder$ = Trim$(Right$(Dir1.Path, 8)) If checkforfolder$ = "faverits" Then cmdCherish.Enabled = False Else cmdCherish.Enabled = True End If 'Otherwise, Else 'show nothing Label2.Caption = "" 'Also disable file copy button cmdCherish.Enabled = False End If SkipDir: 'A path change is extreme so 'stop everything regardless of current status chkPlayAll.value = 0 chkPlaySelect.value = 0 MMSingle.Command = "Close" 'Invalidate 'resume at' variable FileMark = -1 End Sub Private Sub Form_Load() '(M)edia (C)ontrol (I)nterface (App)lication form 'Test for previous instance of application '(We don't want a tussle for the use of sound) 'If so, then If App.PrevInstance Then '(This does not work in VB runtime) 'Tell user MsgBox "A previous instance of this application is already running !", 16, "MIDI CYCLOTRON" 'and end End End If 'Are we running from a media we can write to ? '(If we are, the return value will be, '2 - Removable, 3 - Fixed or 4 - Remote) 'For completeness, 1 = No Root 'If 32bit then (Conditional compilation for API calls) #If Win32 Then 'Get Drive Type. (32bit function uses a String parameter) Drv = GetDriveType(Left(App.Path, 3)) '(e.g. "C:\") 'If Path is CDRom, Drv will = 5 (CDRom specific) 'Otherwise, if 16bit then #Else 'Get Drive Type. (16bit function uses an Integer parameter) '0 = Drive A:\, 1 = Drive B:\, 2 = Drive C:\, etc. D = (Asc(UCase(Left(App.Path, 1))) - 65) 'If Left(App.Path, 1) = 'A' then D will = 0 Since Asc("A") = 65 Drv = GetDriveType(D) 'The 16bit function does not recognise a CD Rom ! 'If Path is CDRom, Drv will = 0 (Unidentifiable drive) 'Good enough for our purpose #End If 'If non writeable drive then jump to avoid testing for, and subsequent 'attempt to create, a 'Favourites' folder If Drv < 2 Or Drv > 4 Then GoTo SkipDir End If 'Error handler in case of missing 'Favourites' folder 'when application is NOT being run from CD On Error GoTo Handle_It '(Form level routine. See 'General') 'Are we in root or not If Right(App.Path, 1) = "\" Then 'Root so, FavouritesPath = App.Path & "faverits" Else 'Heirarchic so, -----------------------v FavouritesPath = App.Path & "\faverits" End If 'Test for existence of favourites folder ChDir FavouritesPath 'Change back to App's path since 'Favourites' now positively 'exists one way or the other (See label 'Handle_It') ChDir App.Path ''We fall through to here if our path is a 'non writeable' drive SkipDir: 'Hide and enable/disable the MCI buttons as appropriate 'to the applications purpose MMSingle.EjectVisible = False MMSingle.RecordVisible = False MMSingle.StepVisible = False MMSingle.BackVisible = False MMSelect.EjectVisible = False MMSelect.RecordVisible = False MMSelect.StepVisible = False MMSelect.BackVisible = False MMSelect.PrevEnabled = False MMSelect.NextEnabled = False MMSelect.PauseEnabled = False MMSelect.PlayEnabled = False MMSelect.StopEnabled = True MMAll.EjectVisible = False MMAll.RecordVisible = False MMAll.StepVisible = False MMAll.BackVisible = False MMAll.PrevEnabled = False MMAll.NextEnabled = False MMAll.PauseEnabled = False MMAll.PlayEnabled = False MMAll.StopEnabled = True 'Centre form on screen Top = (Screen.Height - Height) / 2 Left = (Screen.Width - Width) / 2 'Default height & width when window is in normal state '(See Form_Resize event) DefH = Me.Height DefW = Me.Width 'Set variable default value for graphics timer s = 10 'Form caption leader when playing a file DialogCaption = "MIDI CYCLOTRON - " 'Form caption otherwise Me.Caption = "MIDI CYCLOTRON " 'Define the function of the MCI controls Me.MMAll.DeviceType = "Sequencer" Me.MMSingle.DeviceType = "Sequencer" Me.MMSingle.ZOrder 0 'On Top (Default state) Me.MMSelect.DeviceType = "Sequencer" 'If midi files are displayed then conditionally enable 'the 'Copy To Favourites' button '(Favourites folder will not be the current path at this stage) If File1.ListCount > 0 Then Select Case Drv 'If writeable drive, Case 2, 3, 4 'then enable 'copy To Favourites' button cmdCherish.Enabled = True End Select End If 'Initialise 'resume at' variable for mutli-play options (-1 = invalid) FileMark = -1 'Unload startup banner Unload frmStartup 'and exit before error handling Exit Sub 'Handle 'path not found' error Handle_It: 'Form level subroutine (See General) Handle_Error 'Go back to the line following the one causing the error Resume Next End Sub Private Sub Form_Resize() 'If window is in normal state then If Me.WindowState = 0 Then 'If height or width less than or greater than defaults then If Me.Height <> DefH Or Me.Width <> DefW Then 'set to defaults Me.Height = DefH Me.Width = DefW End If 'Change label colour using the constant black in the event that 'the previous state may have been 2 (Maximised) Label2.ForeColor = black Label3.ForeColor = black Label4.ForeColor = black Label5.ForeColor = black 'Stop timer Timer3.Enabled = False 'Reset form colour using the constant grey Me.BackColor = grey 'If window state is maximised then conditionally 'start timers for graphics ElseIf Me.WindowState = 2 Then 'If graphics are not held then enable rolling If cmdHold.Enabled = True Then 'Seed the random number generator using the 'return value of the system timer (See language reference) Randomize 'Change label colours using the constant white Label2.ForeColor = white Label3.ForeColor = white Label4.ForeColor = white Label5.ForeColor = white 'Start timer Timer3.Enabled = True End If 'Otherwise it's minimised so Else 'If timer not already stopped then If cmdHold.Enabled = True Then 'stop it Timer3.Enabled = False End If End If End Sub Private Sub Form_Unload(Cancel As Integer) 'Ensure devices are closed MMAll.Command = "Close" MMSingle.Command = "Close" MMSelect.Command = "Close" 'Close the program Unload Me End End Sub Private Sub Label3_Click() 'If we use the check box label property then 'we would have to specifically set it's back colour 'when the form is maximised. This label is transparent 'Toggle chkPlaySelect Value If chkPlaySelect.value = 0 Then chkPlaySelect.value = 1 Else chkPlaySelect.value = 0 End If End Sub Private Sub Label4_Click() 'If we use the check box label property then 'we would have to specifically set it's back colour 'when the form is maximised. This label is transparent 'Toggle chkPlaySelect Value If chkPlayAll.value = 0 Then chkPlayAll.value = 1 Else chkPlayAll.value = 0 End If End Sub Private Sub Label5_Click() 'If we use the check box label property then 'we would have to specifically set it's back colour 'when the form is maximised. This label is transparent 'Toggle chkPlaySelect Value If chkLoop.value = 0 Then chkLoop.value = 1 Else chkLoop.value = 0 End If End Sub Private Sub MMAll_Done(NotifyCode As Integer) 'File is finished playing so If chkPlayAll.value = 1 Then 'start timer to play next (or first if loop selected) Timer1.Interval = 1 End If End Sub Private Sub MMAll_StatusUpdate() 'When to move the scroll bar ! Dim value As Integer 'If the device is not playing, reset to the beginning. If Not MMAll.Mode = vbMCIModePlay Then Hscroll1.value = Hscroll1.Max MMAll.UpdateInterval = 0 Exit Sub End If 'Determine how much of the file has played. Set a 'value of the scrollbar between 0 and 100. CurrentValue = CurrentValue + conIntervalPlus value = CInt((CurrentValue / MMAll.Length) * 100) If value > Hscroll1.Max Then value = 100 End If Hscroll1.value = value End Sub Private Sub MMAll_StopClick(Cancel As Integer) 'Stop was clicked so If chkPlayAll.value = 1 Then 'start timer to play next (or first if loop selected) Timer1.Interval = 1 End If End Sub Private Sub MMSingle_PauseClick(Cancel As Integer) ' Set the number of milliseconds between successive ' StatusUpdate events. MMSingle.UpdateInterval = 0 '(stop it) End Sub Private Sub MMSingle_PlayClick(Cancel As Integer) ' Set the number of milliseconds between successive ' StatusUpdate events. MMSingle.UpdateInterval = conInterval 'Set form label caption to show length 'If less then 1 minute then If msecs < 60 Then 'show only seconds Label2.Caption = File1.ListCount & " Files. Music Length " & Int(msecs) & " Secs." 'Otherwise, Else 'show minutes and seconds Label2.Caption = File1.ListCount & " Files. Music Length " & Int(msecs / 60) & " Mins." & msecs Mod (60) & " Secs." End If End Sub Private Sub MMSingle_PrevClick(Cancel As Integer) ' Set the number of milliseconds between successive ' StatusUpdate events. MMSingle.UpdateInterval = 0 '(stop it) ' Reset the scrollbar values. Hscroll1.value = 0 CurrentValue = 0# 'Set to previous MMSingle.Command = "Prev" End Sub Private Sub MMSingle_StatusUpdate() 'When to move the scroll bar Dim value As Integer ' If the device is not playing, reset to the beginning. If Not MMSingle.Mode = vbMCIModePlay Then Hscroll1.value = Hscroll1.Max MMSingle.UpdateInterval = 0 Exit Sub End If ' Determine how much of the file has played. Set a ' value of the scrollbar between 0 and 100. CurrentValue = CurrentValue + conIntervalPlus value = CInt((CurrentValue / MMSingle.Length) * 100) If value > Hscroll1.Max Then value = 100 End If Hscroll1.value = value End Sub Private Sub MMSingle_StopClick(Cancel As Integer) 'Reset label caption Label2.Caption = File1.ListCount & " Files" End Sub Private Sub MMSelect_Done(NotifyCode As Integer) 'File is finished playing so If chkPlaySelect.value = 1 Then 'start timer to play next (or first if looping) Timer2.Interval = 1 End If End Sub Private Sub MMSelect_StatusUpdate() 'When to move the scroll bar ! Dim value As Integer ' If the device is not playing, reset to the beginning. If Not MMSelect.Mode = vbMCIModePlay Then Hscroll1.value = Hscroll1.Max MMSelect.UpdateInterval = 0 Exit Sub End If ' Determine how much of the file has played. Set a ' value of the scrollbar between 0 and 100. CurrentValue = CurrentValue + conIntervalPlus value = CInt((CurrentValue / MMSelect.Length) * 100) If value > Hscroll1.Max Then value = 100 End If Hscroll1.value = value End Sub Private Sub MMSelect_StopClick(Cancel As Integer) 'Stop was clicked so If chkPlayAll.value = 1 Then 'start timer to play next (or first) Timer2.Interval = 1 End If End Sub Private Sub Timer1_Timer() 'If the last file has played check for 'loop' selected If i = File1.ListCount And chkLoop.value = 0 Then 'If not, set counter to first file i = 0 'Reset 'resume at' var FileMark = -1 'and disable it frmOptions.optMethod(3).Enabled = False frmOptions.txtResume.Visible = False 'Uncheck Play All chkPlayAll.value = 0 'and stop timer Timer1.Interval = 0 'then exit Exit Sub 'Otherwise, if last file has played ElseIf i = File1.ListCount Then 'then set to first file i = 0 End If 'Play The Lot ! Dim msec As Double 'Set the number of milliseconds between successive 'StatusUpdate events. (0 = stop it) MMAll.UpdateInterval = 0 'If the device is open, close it. If Not MMAll.Mode = vbMCIModeNotOpen Then MMAll.Command = "Close" End If 'Test for root dir If Right(Dir1.Path, 1) = "\" Then 'Set path to root FilePath = Dir1.Path & File1.List(i) Else 'Otherwise set to heirarchic structure FilePath = Dir1.Path & "\" & File1.List(i) End If ' Set the new filename for the device. MMAll.filename = FilePath 'Trap possible errors On Error GoTo MCI_ERROR 'Open the device MMAll.Command = "Open" 'Trap possible errors On Error GoTo 0 'Set form caption Caption = DialogCaption + File1.List(i) & " File number " & i + 1 & playing 'Set the timing labels on the form. MMAll.TimeFormat = vbMCIFormatMilliseconds msec = (CDbl(MMAll.Length) / 1000) 'Set label caption to include length in seconds or minutes & seconds If msec < 60 Then Label2.Caption = File1.ListCount & " Files. Music Length " & Int(msec) & " Secs." Else Label2.Caption = File1.ListCount & " Files. Music Length " & Int(msec / 60) & " Mins." & msec Mod (60) & " Secs." End If 'Set the scrollbar values. Hscroll1.value = 0 CurrentValue = 0# 'Make the control activate the 'Done' event when finished MMAll.Notify = True 'then start it playing MMAll.Command = "Play" 'Start incrementing scroll bar MMAll.UpdateInterval = conInterval 'Loop or increment file counter 'If the last file has played then If i = File1.ListCount Then 'set it to first file i = 0 'Reset resume at var FileMark = -1 'and disable it frmOptions.optMethod(3).Enabled = False frmOptions.txtResume.Visible = False 'Otherwise Else 'set it to the next i = i + 1 FileMark = i 'and enable it frmOptions.optMethod(3).Enabled = True frmOptions.txtResume.Visible = True frmOptions.txtResume.Text = Str(FileMark) End If 'Stop timer Timer1.Interval = 0 'Exit before error handling Exit Sub MCI_ERROR: 'Public subroutine (See global.bas) DisplayErrorMessageBox Resume MCI_EXIT MCI_EXIT: Unload Me End Sub Private Sub Timer2_Timer() 'If last has been played check for 'loop' selected If y = File1.ListCount And chkLoop.value = 0 Then 'If not selected, set counter to first y = 0 'Reset 'resume at' option FileMark = -1 'and disable it frmOptions.optMethod(3).Enabled = False frmOptions.txtResume.Visible = False 'Uncheck Play Selection chkPlaySelect.value = 0 'and stop timer Timer2.Interval = 0 'then exit Exit Sub 'Otherwise, if last file has been played ElseIf y = File1.ListCount Then 'set to 0 y = 0 End If 'and play those selected ! Dim msec As Double ' Set the number of milliseconds between successive MMSelect.UpdateInterval = 0 '(0 = stop it) ' If the device is open, close it. If Not MMSelect.Mode = vbMCIModeNotOpen Then MMSelect.Command = "Close" End If ' Open the device with the new filename if one or more is selected. If File1.Selected(y) Then 'Set value for resume at option FileMark = y 'and enable it frmOptions.optMethod(3).Enabled = True frmOptions.txtResume.Visible = True frmOptions.txtResume.Text = Str(FileMark + 1) 'Test for root folder If Right(Dir1.Path, 1) = "\" Then 'Set path to root FilePath = Dir1.Path & File1.List(y) Else 'Otherwise set to heirarchal structure FilePath = Dir1.Path & "\" & File1.List(y) End If 'Set filename for device MMSelect.filename = FilePath 'Trap possible errors On Error GoTo MCI_ERROR 'Open the device MMSelect.Command = "Open" 'Trap possible errors On Error GoTo 0 'Set form caption Caption = DialogCaption + File1.List(y) & " File number " & y + 1 ' Set the timing. MMSelect.TimeFormat = vbMCIFormatMilliseconds msec = (CDbl(MMSelect.Length) / 1000) 'Set label caption to include length in seconds or minutes & seconds If msec < 60 Then Label2.Caption = File1.ListCount & " Files. Music Length " & Int(msec) & " Secs." Else Label2.Caption = File1.ListCount & " Files. Music Length " & Int(msec / 60) & " Mins." & msec Mod (60) & " Secs." End If ' Set the scrollbar values. Hscroll1.value = 0 CurrentValue = 0# 'Make the device hold the focus until playing is finished MMSelect.Notify = True 'Start playing MMSelect.Command = "Play" 'Start incrementing scroll bar MMSelect.UpdateInterval = conInterval 'Reset or increment file counter If y = File1.ListCount Then y = 0 Else y = y + 1 End If 'Stop timer Timer2.Interval = 0 'Otherwise, Else 'Check for 'loop' selected If y = File1.ListCount - 1 And chkLoop.value = 0 Then 'If so, set counter to 1 y = 0 'Reset 'resume at' var FileMark = -1 'and disable it frmOptions.optMethod(3).Enabled = False frmOptions.txtResume.Visible = False 'Uncheck Play Selected chkPlaySelect.value = 0 'and stop timer Timer2.Interval = 0 'then exit Exit Sub End If 'Reset or increment file counter 'If the last file has played then If y = File1.ListCount - 1 Then 'go back to file number 1 y = 0 'Otherwise Else 'go to the next y = y + 1 End If End If 'and exit before error handling without stopping timer 'to allow it to test the next file for selection Exit Sub MCI_ERROR: 'Public subroutine (See global.bas) DisplayErrorMessageBox Resume MCI_EXIT MCI_EXIT: Unload Me End Sub Private Sub Timer3_Timer() 'Seed the random number generator using the value of the system timer Randomize 'Set random RGB colours limiting range to between 40 and 215 'for form & controls (this helps in stopping it being too stark) r = ((215 - 40) * Rnd + 40) g = ((215 - 40) * Rnd + 40) B = ((215 - 40) * Rnd + 40) 'Hide the current images Image1(a).Visible = False Image2(a).Visible = False 'If the last images are shown If a = 9 Then 'reset them to first a = 0 'Note: Setting the form colour outside this 'If/Then' construct 'causes double flashing of the images 'Set control & form colours to r, g, b Me.BackColor = RGB(r, g, B) 'and show the first Image1(a).Visible = True Image2(a).Visible = True 'Otherwise Else 'increment them a = a + 1 'Set control & form colours to r, g, b Me.BackColor = RGB(r, g, B) 'and show next images Image1(a).Visible = True Image2(a).Visible = True End If End Sub